package clreqdxml;

#########################################################################
# Perl Object Module to load in the details of the master configuration	#
# XML defaults file and return an object with the details, or an 	#
# error if any are incorrect.						#
#########################################################################

use Data::Dumper;
use Net::Ping;
use XML::Parser;
use Carp qw(cluck);
use strict;

my $error_str=undef;
my $logmsg_hdlr=undef;
my $warnmsg_hdlr=undef;

sub error {
	return $error_str;
}

sub set_logmsg_hdlr {
	$logmsg_hdlr=$_[0];
}

sub set_warnmsg_hdlr {
	$warnmsg_hdlr=$_[0];
}

sub msg {
	if($_[0] eq "log" && defined($logmsg_hdlr)) {
		&{$logmsg_hdlr}($_[1]);
	}
	if($_[0] eq "warn" && defined($warnmsg_hdlr)) {
		&{$logmsg_hdlr}($_[1]);
	}
}

#########################################################################
# Class methods:							#
# ==============							#
# error - return latest error string or undef if everything was OK.	#
# set_logmsg_hdlr -  the routine to call to log a message - no logging	#
# 		     occurs if not set.					#
# set_warnmsg_hdlr - Issue a warning message via this routine - if	#
#		     available.						#
#########################################################################

#########################################################################
# 									#
# The new method will load in the object or set the error condition.	#
# Only following arguement is expect, and will not default it not set.	#
#									#
# filename	The name of the cluster configuration file.		#
#									#
#########################################################################

sub new {
local $clreqdxml::self;
local $clreqdxml::__chardata;
my $class=shift;
my $file=$_[0];

	if(!defined($file)) {
		cluck("Missing mandatory filename argument.") if $::DEBUG;
		$error_str="Missing mandatory filename argument.";
		return undef;
	}

	if(! -e $file) {
		cluck("File $file does not exist.") if $::DEBUG;
		$error_str="File $file does not exist.";
		return undef;
	}
	if(! -f $file) {
		cluck("Object $file is not a regular file.") if $::DEBUG;
		$error_str="Object $file is not a regular file.";
		return undef;
	}
	my @s=stat(_);
	if($s[2] & 07777 != 0600) {
		cluck("Request Daemon configuration file $file must have 0600 permissions!") if $::DEBUG;
		$error_str="Request Daemon configuration file $file must have 0600 permissions!";
		return undef;
	}

	#################################################################
	# Now load in the XML using the XML::Parser - not XML simple.	#
	#################################################################
	
	$clreqdxml::self={};
	my $p;
	$p = new XML::Parser(
			Handlers => { Start => \&lc_handle_start,
					End => \&lc_handle_end,
				       Char => \&lc_handle_char },
			ErrorContext => 5
		);

	$error_str=undef;
	$p->parsefile($file);
	if(defined($error_str)) {
		cluck($error_str) if $::DEBUG;
		return undef;
	}
	if(!defined($clreqdxml::self->{PORT})) {
		cluck("Configuration file missing 'port' element.") if $::DEBUG;
		$error_str="Configuration file missing 'port' element.";
		return undef;
	}
	if(!defined($clreqdxml::self->{REQUESTS})) {
		cluck("Configuration file missing 'requests' element.") if $::DEBUG;
		$error_str="Configuration file missing 'requests' element.";
		return undef;
	}
	if(!defined($clreqdxml::self->{HOSTS})) {
		cluck("Configuration file missing one or more 'host' elements.") if $::DEBUG;
		$error_str="Configuration file missing one or more 'host' elements.";
		return undef;
	}
	bless($clreqdxml::self,$class);
	return $clreqdxml::self;
}

sub lc_handle_start {
my $parser=shift;
my $element=shift;
my %attrs=(@_);
my @context=$parser->context;
my $data;

	$element="\U$element";
	$clreqdxml::__chardata="";

	return if $element eq "CLREQD";
	return if $element eq "REQUESTS";
	return if $element eq "REQUESTS_WS";
	return if $element eq "PORT";
	return if $element eq "WINDOW";
	if($element eq "HOSTS") {
		if(exists($clreqdxml::self->{HOSTS})) {
			$error_str="Element Hosts can only occur once in XML file!";
			$parser->finish;
			return;
		} else {
			$clreqdxml::self->{HOSTS}={};
			return;
		}
	}

	#################################################################
	# A host line must occur inside a HOSTS element and		#
	# must have NAME and optionally IPS attributes.			#
	#################################################################

	if($element eq "HOST") {
		if(scalar(@context)!=2 || $context[1] ne "hosts") {
			$error_str="Element 'host' can only occur inside the 'hosts' element.";
			$parser->finish;
			return;

		}
		if(!exists($attrs{name})) {
			$error_str="'Host' element missing mandatory 'name' attribute.";
			$parser->finish;
			return;
		}
		my $cname=$attrs{name};
		$clreqdxml::self->{HOSTS}->{$cname}={};
		delete $attrs{name};
		if(exists($attrs{ips})) {
			$clreqdxml::self->{HOSTS}->{$cname}->{ips}=$attrs{ips};
			delete $attrs{ips};
		}
		if(scalar(keys(%attrs))) {
			$error_str="'Host' element has unknown attributes - " . join(",",sort(keys(%attrs))) . ".";
			$parser->finish;
			return;
		}
		return;
	}
	$error_str="Unrecognised element '$element' in XML file!";
	$parser->finish;
}

sub lc_handle_end {
my $parser=shift;
my $element=shift;

	$clreqdxml::__chardata =~ s/^\s+//g;	# Get rid of leading white
	$clreqdxml::__chardata =~ s/\s+$//g;	# Get rid of trailing white space
	$element="\U$element";
	if($element eq "PORT") {
		if($clreqdxml::__chardata !~ /^\d+$/) {
			$error_str="Port specified is not an integer number!";
			$parser->finish;
			return;
		}
		$clreqdxml::self->{PORT}=$clreqdxml::__chardata;
		return;
	}
	if($element eq "REQUESTS") {
		if(substr($clreqdxml::__chardata,0,1) ne "/") {
			$clreqdxml::__chardata="$::ENV{TRUECL_CFG}/$clreqdxml::__chardata";
		}
		$clreqdxml::self->{REQUESTS}=$clreqdxml::__chardata;
	}
	if($element eq "REQUESTS_WS") {
		if(substr($clreqdxml::__chardata,0,1) ne "/") {
			$clreqdxml::__chardata="$::ENV{TRUECL_CFG}/$clreqdxml::__chardata";
		}
		$clreqdxml::self->{REQUESTS_WS}=$clreqdxml::__chardata;
	}
}

sub lc_handle_char {
my $parser=shift;
my $str=shift;

	$clreqdxml::__chardata.=$str;
	return ;
}

sub get_host_list {
my $self=shift;
	return (sort(keys(%{$self->{HOSTS}})));
}

sub get_host_details {
my $self=shift;
my $host=shift;

	return(undef) if !exists($self->{HOSTS}->{$host});
	return $self->{HOSTS}->{$host};
}

sub get_requests_value {
my $self=shift;
	return $self->{REQUESTS};
}

sub set_requests_ws_value {
my $self=shift;
my $value=shift;

	$self->{REQUESTS_WS}=$value;
}

sub remove_requests_ws_value {
my $self=shift;
	if(exists($self->{REQUESTS_WS})) {
		delete $self->{REQUESTS_WS};
	}
}

sub get_requests_ws_value {
my $self=shift;

	if(exists($self->{REQUESTS_WS})) {
		return $self->{REQUESTS_WS};
	}
	return undef;
}

sub get_port_value {
my $self=shift;
	return $self->{PORT};
}

#########################################################################
# Add or replace an entry in the configuration - No update to the	#
# disk is made here. Will return:					#
# (0,err) - an error has occured.					#
# (1,undef) - added entry.						#
# args are (hostname,[ipaddresses])					#
#########################################################################

sub add_host_entry {
my $self=shift;
my $host=shift;
my $ips=shift;

	if(!defined($host)) {
		return(0,"Missing 'host' value.");
	}
	if(!defined($ips)) {
		my $ip=gethostbyname($host);
		if(!defined($ip)) {
			return(0,"Unable to resolve '$host' to an IP address.");
		}
		my @y=unpack('C4',$ip);
		$ips=join(".",@y);
	}

	#################################################################
	# Add the details [or replace if existing record]		#
	#################################################################
	$self->{HOSTS}->{$host}->{ips}=$ips;
	return(1,undef);
}

#########################################################################
# Delete the specified entry - if it exists.				#
#########################################################################

sub delete_host_entry {
my $self=shift;
my $host=shift;

	if(!exists($self->{HOSTS}->{$host})) {
		return(0,"Host '$host' does not exist.");
	}
	delete $self->{HOSTS}->{$host};
	return (1,undef);
}

sub get_host_ip_list {
my $self=shift;
my $host=shift;
my @X=();

	if(exists($self->{HOSTS}->{$host})) {
		if(exists($self->{HOSTS}->{$host}->{ips})) {
			@X=split(/,/,$self->{HOSTS}->{$host}->{ips});
			return (@X);
		}
		return ();
	}
	return ();
}

sub get_valid_ip {
my $self=shift;
my $host=shift;
my $timeout=shift;
my @IPS=get_host_ip_list($self,$host);
my ($p,$r);

	$timeout=1 if !defined($timeout);
	if($< == 0) {
		$p = Net::Ping->new("icmp",$timeout);
		for (@IPS) {
			if($p->ping($_)) {
				$p->close;
				return $_;
			}
		}
		$p->close;
		return undef;
	} else {
		return $IPS[0];
	}
}

sub write_config {
my $self=shift;
my $file=shift;
my $fd;

	if(!defined($file)) {
		return(0,"Missing mandatory filename to write to.");
	}
	open($fd,">$file.$$") or
		return(0,"Unable to writ to file '$file.$$': $!");
	print $fd "<?xml version=\"1.0\" standalone=\"yes\"?>\n";
	print $fd "<clreqd>\n";
	print $fd "\t<port>$self->{PORT}</port>\n";
	print $fd "\t<requests>$self->{REQUESTS}</requests>\n";
	print $fd "\t<requests_ws>$self->{REQUESTS_WS}</requests_ws>\n" if (exists($self->{REQUESTS_WS}) && defined($self->{REQUESTS_WS}) && length($self->{REQUESTS_WS}));
	print $fd "\t<hosts>\n";
	for (keys %{$self->{HOSTS}}) {
		print $fd "\t\t<host name=\"$_\" ips=\"$self->{HOSTS}->{$_}->{ips}\"/>\n";
	}
	print $fd "\t</hosts>\n";
	print $fd "</clreqd>\n";
	close($fd);
	if(-f $file) {
		unlink($file);
	}
	rename("$file.$$",$file);
	return(1,undef);
}

1;
